home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / swags-z / sorting.swg / 0042_Complete Sorting Unit.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-11-26  |  6.6 KB  |  165 lines
  1. UNIT Sort;
  2.  
  3.   { These sort routines are for arrays of Integers.  Count is the maximum }
  4.   { number of items in the array.                                         }
  5.  
  6. {****************************************************************************}
  7.                              INTERFACE
  8. {****************************************************************************}
  9. FUNCTION  BinarySearch (VAR A; X : Integer; Count : Integer) : Integer;
  10. PROCEDURE BubbleSort (VAR A; Count : Integer); {slow}
  11. PROCEDURE CombSort (VAR A; Count : Integer);
  12. PROCEDURE QuickSort (VAR A; Count : Integer);  {fast}
  13. FUNCTION  SequentialSearch (VAR A; X : Integer; Count : Integer) : Integer;
  14. PROCEDURE ShellSort (VAR A; Count : Integer);  {moderate}
  15. {****************************************************************************}
  16.                              IMPLEMENTATION
  17. {****************************************************************************}
  18. TYPE
  19.   SortArray = ARRAY[0..0] OF Integer;
  20. {****************************************************************************}
  21. {                                                                            }
  22. {                   Local Procedures and Functions                           }
  23. {                                                                            }
  24. {****************************************************************************}
  25. PROCEDURE Swap (VAR A, B : Integer);
  26. VAR C : Integer;
  27. BEGIN
  28.    C := A;
  29.    A := B;
  30.    B := C;
  31. END;
  32. {****************************************************************************}
  33. {                                                                            }
  34. {                   Global Procedures and Functions                          }
  35. {                                                                            }
  36. {****************************************************************************}
  37. FUNCTION BinarySearch (VAR A; X : Integer; Count : Integer) : Integer;
  38. VAR High, Low, Mid : Integer;
  39. BEGIN
  40.   Low := 1;
  41.   High := Count;
  42.       WHILE High >= Low DO
  43.          BEGIN
  44.             Mid := Trunc(High + Low) DIV 2;
  45.             IF X > SortArray(A)[mid]
  46.                THEN Low := Mid + 1
  47.                ELSE IF X < SortArray(A)[Mid]
  48.                        THEN High := Mid - 1
  49.                        ELSE High := -1;
  50.          END;
  51.       IF High = -1
  52.          THEN BinarySearch := Mid
  53.          ELSE BinarySearch := 0;
  54.    END;
  55. {****************************************************************************}
  56. PROCEDURE BubbleSort (VAR A; Count : Integer);
  57. VAR i, j : Integer;
  58. BEGIN
  59.    FOR i := 2 TO Count DO
  60.      FOR j := Count DOWNTO i DO
  61.        IF SortArray(A)[j-1] > SortArray(A)[j]
  62.           THEN Swap(SortArray(A)[j],SortArray(A)[j-1]);
  63. END;
  64. {****************************************************************************}
  65. PROCEDURE CombSort (VAR A; Count : Integer);
  66.   { The combsort is an optimised version of the bubble sort. It uses a     }
  67.   { decreasing gap in order to compare values of more than one element     }
  68.   { apart.  By decreasing the gap the array is gradually "combed" into     }
  69.   { order ... like combing your hair. First you get rid of the large       }
  70.   { tangles, then the smaller ones ...                                     }
  71.   { There are a few particular things about the combsort.                  }
  72.   { Firstly, the optimal shrink factor is 1.3 (worked out through a        }
  73.   { process of exhaustion by the guys at BYTE magazine). Secondly, by      }
  74.   { never having a gap of 9 or 10, but always using 11, the sort is        }
  75.   { faster.                                                                }
  76.   { This sort approximates an n log n sort - it's faster than any other    }
  77.   { sort I've seen except the quicksort (and it beats that too sometimes). }
  78.   { The combsort does not slow down under *any* circumstances. In fact, on }
  79.   { partially sorted lists (including *reverse* sorted lists) it speeds up.}
  80. CONST ShrinkFactor = 1.3;  { Optimal shrink factor ...       }
  81. VAR
  82.   Gap, i, Temp : Integer;
  83.   Finished : Boolean;
  84. BEGIN
  85.   Gap := Trunc(ShrinkFactor);
  86.   REPEAT
  87.     Finished := TRUE;
  88.     Gap := Trunc(Gap/ShrinkFactor);
  89.     IF Gap < 1
  90.        THEN { Gap must *never* be less than 1 } Gap := 1
  91.        ELSE IF Gap IN [9,10]
  92.                THEN { Optimises the sort ... } Gap := 11;
  93.     FOR i := 1 TO (Count - Gap) DO
  94.       IF SortArray(A)[i] < SortArray(A)[i+gap]
  95.          THEN BEGIN
  96.                 Swap(SortArray(A)[i],SortArray(A)[i + Gap]);
  97.                 Finished := FALSE;
  98.               END;
  99.   UNTIL (Gap = 1) AND Finished;
  100. END;
  101. {****************************************************************************}
  102. PROCEDURE QuickSort (VAR A; Count : Integer);
  103.   {**************************************************************************}
  104.   PROCEDURE PartialSort(LowerBoundary, UpperBoundary : Integer; VAR A);
  105.   VAR ii, l1, r1, i, j, k : Integer;
  106.   BEGIN
  107.     k := (SortArray(A)[LowerBoundary] + SortArray(A)[UpperBoundary]) DIV 2;
  108.     i := LowerBoundary;
  109.     j := UpperBoundary;
  110.     REPEAT
  111.       WHILE SortArray(A)[i] < k DO Inc(i);
  112.       WHILE k < SortArray(A)[j] DO Dec(j);
  113.       IF i <= j
  114.          THEN BEGIN
  115.                 Swap(SortArray(A)[i],SortArray(A)[j]);
  116.                 Inc(i);
  117.                 Dec(j);
  118.               END;
  119.     UNTIL i > j;
  120.     IF LowerBoundary < j
  121.        THEN PartialSort(LowerBoundary,j,A);
  122.     IF i < UpperBoundary
  123.        THEN PartialSort(UpperBoundary,i,A);
  124.   END;
  125.   {*************************************************************************}
  126. BEGIN
  127.   PartialSort(1,Count,A);
  128. END;
  129. {****************************************************************************}
  130. FUNCTION SequentialSearch (VAR A; X : Integer; Count : Integer) : Integer;
  131. VAR i : Integer;
  132. BEGIN
  133.   FOR i := 1 TO Count DO
  134.     IF X = Sortarray(A)[i]
  135.        THEN BEGIN
  136.               SequentialSearch := i;
  137.               Exit;
  138.             END;
  139.   SequentialSearch := 0;
  140. END;
  141. {****************************************************************************}
  142. PROCEDURE ShellSort (VAR A; Count : Integer);
  143. VAR Gap, i, j, k : Integer;
  144. BEGIN
  145.   Gap := Count DIV 2;
  146.   WHILE (gap > 0) DO
  147.     BEGIN
  148.       FOR i := (Gap + 1) TO Count DO
  149.         BEGIN
  150.           j := i - Gap;
  151.           WHILE (j > 0) DO
  152.             BEGIN
  153.               k := j + gap;
  154.               IF (SortArray(A)[j] <= SortArray(A)[k])
  155.                  THEN j := 0
  156.                  ELSE Swap(SortArray(A)[j],SortArray(A)[k]);
  157.               j := j - Gap;
  158.             END;
  159.         END;
  160.       Gap := Gap DIV 2;
  161.     END;
  162. END;
  163. {*****************************************************************************}
  164. END.
  165.